home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Libris Britannia 4
/
science library(b).zip
/
science library(b)
/
PROGRAMM
/
DB_CLIPP
/
H245.ZIP
/
NFSRC21.ZIP
/
AREDIT.PRG
< prev
next >
Wrap
Text File
|
1991-08-16
|
11KB
|
309 lines
/*
* File......: ArEdit.prg
* Author....: James J. Orlowski, M.D.
* CIS ID....: 72707,601
* Date......: $Date: 15 Aug 1991 23:05:56 $
* Revision..: $Revision: 1.2 $
* Log file..: $Logfile: E:/nanfor/src/aredit.prv $
*
*
* Modification history:
* ---------------------
*
* $Log: E:/nanfor/src/aredit.prv $
*
* Rev 1.2 15 Aug 1991 23:05:56 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 12 Jun 1991 00:42:38 GLENN
* A referee suggested changing the documentation such that the return value
* is shown as "xElement" rather than "cElement" because the function
* can return different types.
*
* Rev 1.0 07 Jun 1991 23:03:24 GLENN
* Initial revision.
*
*
*/
/*
Some notes:
The tbmethods section is a short cut from Spence's book instead
of using the longer DO CASE method.
Jim Gale showed me the basic array browser and Robert DiFalco
showed me the improved skipblock in public messages on Nanforum.
I added the functionality of the "Edit Get" code block
(ie bGetFunc), TestGet() demo, and the add/delete rows.
*/
/* $DOC$
* $FUNCNAME$
* FT_AREDIT()
* $CATEGORY$
* Array
* $ONELINER$
* 2 dimensional array editing function using TBrowse
* $SYNTAX$
* FT_AREDIT( <nTop>, <nLeft>, <nBottom>, <nRight>, <Array Name>, ;
* <nElem>, <aHeadings>, <aBlocks> [, <bGetFunc> ] ) -> xElement
* $ARGUMENTS$
* <nTop>, <nLeft>, <nBottom>, <nRight> are coordinates for TBrowse
*
* <Array Name> is name of 2 dimensional to array edit
*
* <nElem> is pointer for element in array
*
* <aHeadings> is array of column headings
*
* <aBlocks> is array of blocks describing each array element
*
* [ <bGetFunc> ] is get editing function for handling individual elements
* $RETURNS$
* Value of element positioned on when exit FT_AREDIT()
* The type of this value depends on what is displayed.
* $DESCRIPTION$
* This function allows you to position yourself in an array,
* add and delete rows with the <F7> and <F8> keys,
* and pass a UDF with information to edit the individual gets.
* $EXAMPLES$
* FT_AREDIT(3, 5, 18, 75, ar, @nElem, aHeadings, aBlocks)
*
* This example will allow you to browse a 2 dimensional array
* But you can't edit it since there is no GetBlock UDF
* It allows the user to hit ENTER to select an element or ESC to
* return 0
*
* * This second example shows how to edit a 2 dimensional array
* * as might be done to edit an invoice
*
* LOCAL i, ar[3, 26], aBlocks[3], aHeadings[3]
* LOCAL nElem := 1, bGetFunc
*
* * Set up two dimensional array "ar"
*
* FOR i = 1 TO 26
* ar[1, i] := i // 1 -> 26 Numeric
* ar[2, i] := CHR(i+64) // "A" -> "Z" Character
* ar[3, i] := CHR(91-i) // "Z" -> "A" Character
* NEXT i
*
* * SET UP aHeadings Array for column headings
*
* aHeadings := { "Numbers", "Letters", "Reverse" }
*
* * Need to set up individual array blocks for each TBrowse column
*
* aBlocks[1] := {|| STR(ar[1, nElem], 2) } // prevent default 10 spaces
* aBlocks[2] := {|| ar[2, nElem] }
* aBlocks[3] := {|| ar[3, nElem] }
*
* * set up TestGet() as the passed Get Function so FT_ArEdit knows how
* * to edit the individual gets.
*
* bGetFunc := { | b, ar, nDim, nElem | TestGet(b, ar, nDim, nElem) }
* SetColor( "N/W, W/N, , , W/N" )
* CLEAR SCREEN
* FT_AREDIT(3, 5, 18, 75, ar, @nElem, aHeadings, aBlocks, bGetFunc)
*
* $END$
*/
#include "inkey.ch"
* Default heading, column, footer separators
#define DEF_HSEP "═╤═"
#define DEF_CSEP " │ "
#define DEF_FSEP "═╧═"
* Default info for tb_methods section
#define KEY_ELEM 1
#define BLK_ELEM 2
#ifdef FT_TEST
PROCEDURE Test
* Thanks to Jim Gale for helping me understand the basics
LOCAL i, ar[3, 26], aBlocks[3], aHeadings[3], nElem := 1, bGetFunc, cRet
* set up 2 dimensional array ar[]
FOR i = 1 TO 26
ar[1, i] := i // 1 -> 26 Numeric
ar[2, i] := CHR(i+64) // "A" -> "Z" Character
ar[3, i] := CHR(91-i) // "Z" -> "A" Character
NEXT i
* Set Up aHeadings[] for column headings
aHeadings := { "Numbers", "Letters", "Reverse" }
* Set Up Blocks Describing Individual Elements in Array ar[]
aBlocks[1] := {|| STR(ar[1, nElem], 2)} // to prevent default 10 spaces
aBlocks[2] := {|| ar[2, nElem]}
aBlocks[3] := {|| ar[3, nElem]}
* Set up TestGet() as bGetFunc
bGetFunc := {|b, ar, nDim, nElem|TestGet(b, ar, nDim, nElem)}
SET SCOREBOARD OFF
SetColor( "W/N")
CLEAR SCREEN
@ 21,4 SAY "Use Cursor Keys To Move Between Fields, <F7> = Delete Row, <F8> = Add Row"
@ 22,7 SAY "<ESC> = Quit Array Edit, <Enter> or <Any Other Key> Edits Element"
SetColor( "N/W, W/N, , , W/N" )
cRet := FT_ArEdit(3, 5, 18, 75, ar, @nElem, aHeadings, aBlocks, bGetFunc)
SetColor( "W/N")
CLEAR SCREEN
? cRet
? "Lastkey() = ESC:", LASTKEY() == K_ESC
RETURN
FUNCTION TestGet( b, ar, nDim, nElem)
LOCAL GetList := {}
LOCAL nRow := ROW()
LOCAL nCol := COL()
LOCAL cSaveScrn := SAVESCREEN(21, 0, 22, MaxCol())
LOCAL cOldColor := SetColor( "W/N")
@ 21, 0 CLEAR TO 22, MaxCol()
@ 21,29 SAY "Editing Array Element"
SetColor(cOldColor)
DO CASE
CASE nDim == 1
@ nRow, nCol GET ar[1, nElem] PICTURE "99"
READ
b:refreshAll()
CASE nDim == 2
@ nRow, nCol GET ar[2, nElem] PICTURE "!"
READ
b:refreshAll()
CASE nDim == 3
@ nRow, nCol GET ar[3, nElem] PICTURE "!"
READ
b:refreshAll()
ENDCASE
RESTSCREEN(21, 0, 22, MaxCol(), cSaveScrn)
@ nRow, nCol SAY ""
RETURN(.t.)
#endif
FUNCTION FT_ArEdit( nTop, nLeft, nBot, nRight, ;
ar, nElem, aHeadings, aBlocks, bGetFunc)
* ANYTYPE[] ar - Array to browse
* NUMERIC nElem - Element In Array
* CHARACTER[] aHeadings - Array of Headings for each column
* BLOCK[] aBlocks - Array containing code block for each column.
* CODE BLOCK bGetFunc - Code Block For Special Get Processing
* NOTE: When evaluated a code block is passed the array element to
* be edited
LOCAL exit_requested := .F., nKey, meth_no, ;
cSaveWin, i, b, column
LOCAL nDim, nWorkRow, cType, cVal
LOCAL tb_methods := ;
{ ;
{K_DOWN, {|b| b:down()}}, ;
{K_UP, {|b| b:up()}}, ;
{K_PGDN, {|b| b:pagedown()}}, ;
{K_PGUP, {|b| b:pageup()}}, ;
{K_CTRL_PGUP, {|b| b:gotop()}}, ;
{K_CTRL_PGDN, {|b| b:gobottom()}}, ;
{K_RIGHT, {|b| b:right()}}, ;
{K_LEFT, {|b| b:left()}}, ;
{K_HOME, {|b| b:home()}}, ;
{K_END, {|b| b:end()}}, ;
{K_CTRL_LEFT, {|b| b:panleft()}}, ;
{K_CTRL_RIGHT, {|b| b:panright()}}, ;
{K_CTRL_HOME, {|b| b:panhome()}}, ;
{K_CTRL_END, {|b| b:panend()}} ;
}
cSaveWin := SaveScreen(nTop, nLeft, nBot, nRight)
@ nTop, nLeft TO nBot, nRight
b := TBrowseNew(nTop + 1, nLeft + 1, nBot - 1, nRight - 1)
b:headsep := DEF_HSEP
b:colsep := DEF_CSEP
b:footsep := DEF_FSEP
b:gotopblock := {|| nElem := 1}
b:gobottomblock := {|| nElem := LEN(ar[1])}
* skipblock originally coded by Robert DiFalco
b:SkipBlock := {|nSkip, nStart| nStart := nElem,;
nElem := MAX( 1, MIN( LEN(ar[1]), nElem + nSkip ) ),;
nElem - nStart }
FOR i = 1 TO LEN(aBlocks)
column := TBColumnNew(aHeadings[i], aBlocks[i] )
b:addcolumn(column)
NEXT
exit_requested = .F.
DO WHILE !exit_requested
DO WHILE NEXTKEY() == 0 .AND. !b:stabilize()
ENDDO
nKey := INKEY(0)
meth_no := ASCAN(tb_methods, {|elem| nKey = elem[KEY_ELEM]})
IF meth_no != 0
EVAL(tb_methods[meth_no, BLK_ELEM], b)
ELSE
DO CASE
CASE nKey == K_F7
FOR nDim = 1 TO LEN(ar)
ADEL(ar[nDim], nElem)
ASIZE(ar[nDim], LEN(ar[nDim]) - 1)
NEXT
b:refreshAll()
CASE nKey == K_F8
FOR nDim = 1 TO LEN(ar)
* check valtype of current element before AINS()
cType := VALTYPE(ar[nDim, nElem])
cVal := ar[nDim, nElem]
ASIZE(ar[nDim], LEN(ar[nDim]) + 1)
AINS(ar[nDim], nElem)
IF cType == "C"
ar[nDim, nElem] := SPACE(LEN(cVal))
ELSEIF cType == "N"
ar[nDim, nElem] := 0
ELSEIF cType == "L"
ar[nDim, nElem] := .f.
ELSEIF cType == "D"
ar[nDim, nElem] := CTOD(" / / ")
ENDIF
NEXT
b:refreshAll()
CASE nKey == K_ESC
exit_requested := .T.
* Other exception handling ...
CASE VALTYPE(bGetFunc) == "B"
IF nKey <> K_ENTER
* want last key to be part of GET edit so KEYBOARD it
KEYBOARD CHR(LASTKEY())
ENDIF
EVAL(bGetFunc, b, ar, b:colPos, nElem )
* after get move to next field
KEYBOARD IF(b:colPos < b:colCount, ;
CHR(K_RIGHT), CHR(K_HOME) + CHR(K_DOWN) )
* Placing K_ENTER here below Edit Block (i.e. bGetFunc)
* defaults K_ENTER to Edit when bGetFunc Is Present
* BUT if no bGetFunc, then K_ENTER selects element to return
CASE nKey == K_ENTER
exit_requested := .T.
ENDCASE
ENDIF // meth_no != 0
ENDDO // WHILE !exit_requested
RestScreen(nTop, nLeft, nBot, nRight, cSaveWin)
* if no bGetFunc then ESC returns 0, otherwise return value of last element
RETURN IF( VALTYPE(bGetFunc) == NIL .AND. nKey == K_ESC, ;
0, ar[b:colPos, nElem] )
* EOFcn FT_ArEdit()